home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / tsort.scm < prev    next >
Text File  |  1999-04-19  |  1KB  |  47 lines
  1. ;;; "tsort.scm" Topological sort
  2. ;;; Copyright (C) 1995 Mikael Djurfeldt
  3. ;
  4. ; This code is in the public domain.
  5.  
  6. ;;; The algorithm is inspired by Cormen, Leiserson and Rivest (1990)
  7. ;;; "Introduction to Algorithms", chapter 23
  8.  
  9. (require 'hash-table)
  10. (require 'primes)
  11.  
  12. (define (topological-sort dag pred)
  13.   (if (null? dag)
  14.       '()
  15.       (let* ((adj-table (make-hash-table
  16.              (car (primes> (length dag) 1))))
  17.          (insert (hash-associator pred))
  18.          (lookup (hash-inquirer pred))
  19.          (sorted '()))
  20.     (letrec ((visit
  21.           (lambda (u adj-list)
  22.             ;; Color vertex u
  23.             (insert adj-table u 'colored)
  24.             ;; Visit uncolored vertices which u connects to
  25.             (for-each (lambda (v)
  26.                 (let ((val (lookup adj-table v)))
  27.                   (if (not (eq? val 'colored))
  28.                       (visit v (or val '())))))
  29.                   adj-list)
  30.             ;; Since all vertices downstream u are visited
  31.             ;; by now, we can safely put u on the output list
  32.             (set! sorted (cons u sorted)))))
  33.       ;; Hash adjacency lists
  34.       (for-each (lambda (def)
  35.               (insert adj-table (car def) (cdr def)))
  36.             (cdr dag))
  37.       ;; Visit vertices
  38.       (visit (caar dag) (cdar dag))
  39.       (for-each (lambda (def)
  40.               (let ((val (lookup adj-table (car def))))
  41.             (if (not (eq? val 'colored))
  42.                 (visit (car def) (cdr def)))))
  43.             (cdr dag)))
  44.     sorted)))
  45.  
  46. (define tsort topological-sort)
  47.